home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / FILEPOS.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  4.7 KB  |  104 lines
  1. ; FILEPOS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Set-File-Position                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by:                 Date:                 *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ; SET-FILE-POSITION will move the file pointer to a new position
  23. ; and update a pointer in the buffer to point to a new location.
  24. ; The offset variable can be:
  25. ;                     0 for positioning from the start of the file
  26. ;                     1 for positioning relative to the current position
  27. ;                     2 for positioning from the end of the file
  28.  
  29. (define set-file-position!                 ; ==> filepos.s
  30.   (lambda (port #-of-bytes offset)
  31.     (let ((current-pos (%reify-port port 9))
  32.           (end-of-buffer (%reify-port port 10))
  33.           (new-pos '())
  34.           (current-chunk (max 0 (-1+ (%reify-port port 12))))
  35.           (new-chunk '())
  36.           (messages '())
  37.           (file-size (+ (* (%reify-port port 4) 65536) (%reify-port port 6)))
  38.           (port-flags (%reify-port port 11)))
  39.       (if (and (port? port)
  40.                (= (bitwise-and port-flags 4) 0))
  41.           (case offset
  42.             ((0) ; offset from the start of the file
  43.              (set! #-of-bytes (abs #-of-bytes))
  44.              (if (= (bitwise-and port-flags 3) 0)
  45.                  (set! #-of-bytes (min #-of-bytes file-size)))
  46.              (set! new-chunk (truncate (/ #-of-bytes 256)))
  47.              (set! new-pos (- #-of-bytes (* new-chunk 256)))
  48.              (if (and (< new-pos end-of-buffer)
  49.                       (>= new-pos 0)
  50.                       (= (bitwise-and port-flags 3) 0) ; open for reading
  51.                       (= new-chunk current-chunk))
  52.                  (%reify-port! port 9 new-pos)
  53.                  (%sfpos port new-chunk new-pos)))
  54.  
  55.             ((1) ; offset from the current position
  56.              (set! new-pos (+ current-pos #-of-bytes))
  57.              (if (and (< new-pos end-of-buffer)
  58.                       (>= new-pos 0)
  59.                       (= (bitwise-and port-flags 3) 0)) ; open for reading
  60.                  (%reify-port! port 9 new-pos)
  61.                  (begin
  62.                    (set! new-pos (+ (+ current-pos (* 256 current-chunk))
  63.                                     #-of-bytes)) ; offset from the begining of the file
  64.                    (if (and (> new-pos file-size)
  65.                             (= (bitwise-and port-flags 3) 0))
  66.                        (set! new-pos file-size))
  67.                    (if (< new-pos 0)
  68.                        (set! new-pos 0))
  69.                    (set! new-chunk (truncate (/ new-pos 256)))
  70.                    (%sfpos port new-chunk (- new-pos (* new-chunk 256))))))
  71.  
  72.             ((2) ; offset from the end of the file
  73.              (set! #-of-bytes (min (abs #-of-bytes) file-size))
  74.              (set! new-pos (- file-size (abs #-of-bytes))) ; absolute position
  75.              (set! new-chunk (truncate (/ new-pos 256)))
  76.              (set! new-pos (- newpos (* new-chunk 256))) ; buffer position
  77.              (if (= (bitwise-and port-flags 3) 0)
  78.                  (if (and (< new-pos end-of-buffer)
  79.                           (>= new-pos 0)
  80.                           (= new-chunk current-chunk))
  81.                      (%reify-port! port 9 new-pos)
  82.                      (%sfpos port new-chunk new-pos))
  83.                  (display "Offset from the end of the file can only be used with files open for reading!")
  84.                  ))
  85.             (else (display "Offset must be 0, 1 or 2!")))
  86.           (display "First parameter must be a file!")))))
  87.  
  88. ;******************************************************************
  89. ;* get-file-position will return the current file position in the *
  90. ;* number of bytes from the beginning of the file.                *
  91. ;******************************************************************
  92.  
  93. (define get-file-position
  94.   (lambda (port)
  95.     (let (( result '())
  96.           (chunk (max 1 (%reify-port port 12))))
  97.       (if (and (port? port)
  98.                (= (bitwise-and (%reify-port port 11) 4) 0))
  99.           (set! result (+ (* 256 (-1+ chunk)) ; chunk#
  100.                           (%reify-port port 9)))        ; current position
  101.           (set! result "Needs to be a port/file object!"))
  102.       result)))
  103.  
  104.